home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / progjour / 1988 / 05 / objdraw.pas < prev    next >
Pascal/Delphi Source File  |  1988-08-18  |  10KB  |  328 lines

  1. Copyright Tom Swan, 1988.  All Rights Reserved.
  2.  
  3. PROGRAM ObjDraw;
  4.  
  5. { Raw beginnings of an object-oriented graphics program,
  6. demonstrating a practical use for variable-length data structures. 
  7. Written for Programmer's Journal by Tom Swan, Swan Software, P.O. Box
  8. 206, Lititz PA 17543. }
  9.  
  10.  
  11. USES  Crt, Graph;
  12.  
  13.  
  14. CONST
  15.  
  16.    FileName = 'OBJECTS.TXT';     { Graphics objects file name }
  17.    GrPath = 'C:\TPAS4';          { Pathname to BGI drivers }
  18.    MaxWord = 65535;              { Maximum Word value }
  19.  
  20.  
  21. TYPE
  22.  
  23.    ObjType = ( {0} ObjPoint, {1} ObjLine, {2} ObjRect, {3} ObjCircle );
  24.  
  25.    PointRec =                    { Single-pixel points }
  26.       RECORD
  27.          x, y : Integer;               { Location of point }
  28.          pointColor : Word             { Color of point }
  29.       END;
  30.  
  31.    LineRec =                     { Straight lines }
  32.       RECORD
  33.          x1, y1, x2, y2 : Integer;     { Line endpoints }
  34.          lineColor : Word              { Line color }
  35.       END;
  36.  
  37.    RectRec =                     { Squares and rectangles }
  38.       RECORD
  39.          x1, y1, x2, y2 : Integer;     { Rectangle corners }
  40.          lineColor : Word;             { Outline color }
  41.          fillColor : Word              { Interior color (0=none) }
  42.       END;
  43.  
  44.    CircleRec =                   { Circles }
  45.       RECORD
  46.          x, y : Integer;               { Center coordinate }
  47.          radius : Word;                { Length of radius in pixels }
  48.          lineColor : Word;             { Outline color }
  49.          fillColor : Word              { Interior color (0=none) }
  50.       END;
  51.  
  52.    ObjPtr = ^ObjRec;             { Pointer to various graphics objects }
  53.    ObjRec =
  54.       RECORD CASE objKind : ObjType OF
  55.          ObjPoint    : ( onePoint  : PointRec  );
  56.          ObjLine     : ( oneLine   : LineRec   );
  57.          ObjRect     : ( oneRect   : RectRec   );
  58.          ObjCircle   : ( oneCircle : CircleRec )
  59.       END;
  60.  
  61.    ObjListPtr = ^ObjList;        { Pointer to list of graphics objects }
  62.    ObjList = 
  63.       RECORD
  64.          numObjects : Word;                     { Number of objects }
  65.          objects : ARRAY[ 0 .. 0 ] OF ObjPtr    { Variable-length array }
  66.       END;
  67.  
  68.  
  69. VAR
  70.  
  71.    obj : ObjListPtr;    { Pointer to list of objects }
  72.  
  73.  
  74.  
  75. PROCEDURE NewObjList( n : Word; VAR obj : ObjListPtr );
  76.  
  77. { Return pointer obj to an ObjList record large enough to hold n
  78. ObjPtr pointers in the obj^.objects array field.  If obj=Nil on
  79. return, then 1) n=0; or 2) bytes requested > MaxWord; or 3) enough
  80. memory for n items is not available. }
  81.  
  82. VAR   size : LongInt;   { Number of bytes to allocate }
  83.  
  84. BEGIN
  85.    size := SizeOf( Word ) + ( LongInt(n) * SizeOf( ObjRec ) );
  86.    IF ( size = 0 ) OR ( size > MaxWord ) THEN obj := Nil ELSE
  87.    BEGIN
  88.       GetMem( obj, size );    { Out-of-memory error sets obj to Nil }
  89.       IF obj <> Nil 
  90.          THEN obj^.numObjects := n
  91.    END { if }
  92. END; { NewObjList }
  93.  
  94.  
  95. PROCEDURE NewObj( n : Word; VAR obj : ObjPtr );
  96.  
  97. { Return pointer obj to an ObjRec record large enough to hold n
  98. bytes plus the record tag field.  Out-of-memory error returns
  99. obj = Nil. }
  100.  
  101. BEGIN
  102.    GetMem( obj, n + SizeOf( ObjType ) )
  103. END; { NewObj }
  104.  
  105.  
  106. FUNCTION NextObject( VAR f : Text ) : ObjPtr;
  107.  
  108. { Read next object data from disk, creating an ObjRec record large
  109. enough to hold the data, and returning the address of this record
  110. as the function result.  Out-of-memory error returns Nil. }
  111.  
  112. VAR   objCode : Word;      { Object code number (from data file) }
  113.       p : ObjPtr;          { Temporary single object pointer }
  114.  
  115.    FUNCTION LoadPoint : ObjPtr;
  116.    { Load one point object }
  117.    BEGIN
  118.       NewObj( SizeOf( PointRec ), p );    { Allocate memory }
  119.       IF p <> Nil THEN WITH p^.onePoint DO 
  120.          Read( f, x, y, pointColor );     { Read data }
  121.       LoadPoint := p                      { Return function result }
  122.    END; { LoadPoint }
  123.  
  124.    FUNCTION LoadLine : ObjPtr;
  125.    { Load one line object }
  126.    BEGIN
  127.       NewObj( SizeOf( LineRec ), p );
  128.       IF p <> Nil THEN WITH p^.oneLine DO 
  129.          Read( f, x1, y1, x2, y2, lineColor );
  130.       LoadLine := p
  131.    END; { LoadLine }
  132.  
  133.    FUNCTION LoadRect : ObjPtr;
  134.    { Load one rectangle object }
  135.    BEGIN
  136.       NewObj( SizeOf( RectRec ), p );
  137.       IF p <> Nil THEN WITH p^.oneRect DO 
  138.          Read( f, x1, y1, x2, y2, lineColor, fillColor );
  139.       LoadRect := p
  140.    END; { LoadRect }
  141.  
  142.    FUNCTION LoadCircle : ObjPtr;
  143.    { Load one circle object }
  144.    BEGIN
  145.       NewObj( SizeOf( CircleRec ), p );
  146.       IF p <> Nil THEN WITH p^.oneCircle DO
  147.          Read( f, x, y, radius, lineColor, fillColor );
  148.       LoadCircle := p
  149.    END; { LoadCircle }
  150.  
  151. BEGIN
  152.    Read( f, objCode );                 { Read object code number }
  153.    CASE ObjType( objCode ) OF
  154.       ObjPoint    : p := LoadPoint;    { Read point data }
  155.       ObjLine     : p := LoadLine;     { Read line data }
  156.       ObjRect     : p := LoadRect;     { Read rectangle data }
  157.       ObjCircle   : p := LoadCircle    { Read circle data }
  158.    END; { case }
  159.    IF p <> Nil 
  160.       THEN p^.objKind := ObjType( objCode );   { Save code as tag field }
  161.    NextObject := p                     { Return function result }
  162. END; { NextObject }
  163.  
  164.  
  165. PROCEDURE LoadFile( VAR obj : ObjListPtr );
  166.  
  167. { Read graphics objects from a disk file.  Halts on errors. }
  168.  
  169. VAR   f : Text;               { Text file variable }
  170.       n : Word;               { Number of objects }
  171.       i : Word;               { For-loop control variable }
  172.  
  173. BEGIN
  174.    Assign( f, FileName );     { Assign file name to file variable }
  175.    Reset( f );                { Open file for input }
  176.    Read( f, n );              { Read number of objects }
  177.    NewObjList( n, obj );      { Create array to hold list of n objects }
  178.    IF obj = Nil THEN          { Check for bad n or short memory }
  179.    BEGIN
  180.       Writeln;
  181.       Writeln( 'Cannot allocate space for ', n, ' objects' );
  182.       Writeln( 'Memory available = ', MemAvail );
  183.       Halt(1)
  184.    END; { if }
  185.    FOR i := 1 TO n DO         { Read n objects from disk }
  186.       obj^.objects[i-1]       { Read next object and }
  187.          := NextObject( f );  {  assign to variable-length array }
  188.    Close( f )
  189. END; { LoadFile }
  190.  
  191.  
  192. PROCEDURE ShowOneObj( obj : ObjListPtr; n : Word );
  193.  
  194. { Display object number n in object list addressed by obj pointer. 
  195. Assumes obj is not Nil.  Ignores any Nil pointers in obj^.objects
  196. array. }
  197.  
  198. VAR   p : ObjPtr;    { Holds copy of obj^.objects[n] }
  199.  
  200.    PROCEDURE ShowPoint( VAR onePoint : PointRec );
  201.    { Display point object }
  202.    BEGIN
  203.       WITH onePoint DO
  204.          PutPixel( x, y, pointColor )
  205.    END; { ShowPoint }
  206.  
  207.    PROCEDURE ShowLine( VAR oneLine : LineRec );
  208.    { Display Line object }
  209.    BEGIN
  210.       WITH oneLine DO
  211.       BEGIN
  212.          SetColor( lineColor );
  213.          Line( x1, y1, x2, y2 )
  214.       END { with }
  215.    END; { ShowLine }
  216.  
  217.    PROCEDURE ShowRect( VAR oneRect : RectRec );
  218.    { Display Rect object }
  219.    BEGIN
  220.       WITH oneRect DO
  221.       BEGIN
  222.          IF fillColor > 0 THEN
  223.          BEGIN
  224.             SetFillStyle( SolidFill, fillColor );
  225.             Bar( x1, y1, x2, y2 )
  226.          END; { if }
  227.          SetColor( lineColor );
  228.          Rectangle( x1, y1, x2, y2 )
  229.       END { with }
  230.    END; { ShowRect }
  231.  
  232.    PROCEDURE ShowCircle( VAR oneCircle : CircleRec );
  233.    { Display Circle object }
  234.    BEGIN
  235.       WITH oneCircle DO
  236.       BEGIN
  237.          SetColor( lineColor );
  238.          Circle( x, y, radius );
  239.          IF fillColor > 0 THEN
  240.          BEGIN
  241.             SetFillStyle( SolidFill, fillColor );
  242.             FloodFill( x, y, lineColor )
  243.          END { if }
  244.       END { with }
  245.    END; { ShowCircle }
  246.  
  247. BEGIN
  248.    WITH obj^ DO
  249.    IF ( 0 <= n ) AND ( n < numObjects ) THEN
  250.    BEGIN
  251.       p := objects[n];
  252.       IF p <> Nil THEN WITH p^ DO
  253.       CASE objKind OF
  254.          ObjPoint    : ShowPoint( onePoint );
  255.          ObjLine     : ShowLine( oneLine );
  256.          ObjRect     : ShowRect( oneRect );
  257.          ObjCircle   : ShowCircle( oneCircle )
  258.       END { case }
  259.    END { if }
  260. END; { ShowOneObj }
  261.  
  262.  
  263. PROCEDURE ShowAllObjects( obj : ObjListPtr );
  264.  
  265. { Display all objects addressed by object list pointer obj.  Assumes
  266. that obj is not Nil. }
  267.  
  268. VAR   i : Word;      { For-loop control variable }
  269.  
  270. BEGIN
  271.    FOR i := 1 TO obj^.numObjects DO
  272.       ShowOneObj( obj, i - 1 );
  273. END; { ShowAllObjects }
  274.  
  275.  
  276. PROCEDURE DoGraphics( obj : ObjListPtr );
  277.  
  278. { Initialize graphics screen and display objects addressed by obj. }
  279.  
  280. VAR   grDriver, grMode, grError : Integer;   { BGI graphics variables }
  281.       ch : Char;     { Holds keypresses }
  282.  
  283. BEGIN
  284.    grDriver := Detect;
  285.    InitGraph( grDriver, grMode, grPath );
  286.    grError := GraphResult;
  287.    IF grError <> GrOk
  288.     THEN 
  289.       Writeln( 'Graphics error : ', GraphErrorMsg( grError ) )
  290.     ELSE 
  291.       BEGIN
  292.          ShowAllObjects( obj );
  293.          REPEAT 
  294.             ch := ReadKey;
  295.             ShowOneObj( obj, ( Ord(ch) - Ord('0') ) - 1 )
  296.          UNTIL ch = Chr(27);
  297.          CloseGraph
  298.       END { else }
  299. END; { DoGraphics }
  300.  
  301.  
  302. { The following custom heap-error trap function lets GetMem and New
  303. return Nil pointers if memory allocation requests fail due to
  304. insufficient memory. }
  305.  
  306. {$F+}    { Switch on far-procedure generation }
  307. FUNCTION HeapErrorTrap( size : Word ) : Integer;
  308. BEGIN
  309.    HeapErrorTrap := 1      { New & GetMem: return Nil if out-of-memory }
  310. END; { HeapErrorTrap }
  311. {$F-}    { Switch off far-procedure generation }
  312.  
  313.  
  314. BEGIN
  315.    HeapError := @HeapErrorTrap;  { Assign custom heap-error trap address }
  316.    Writeln;
  317.    Writeln( 'Welcome to ObjDraw' );
  318.    Writeln;
  319.    Writeln( 'Reads data from file ', FileName );
  320.    Writeln( 'Press digit keys to bring objects to the front' );
  321.    Writeln( 'Press Esc to quit' );
  322.    Writeln;
  323.    Write( 'Press Enter to begin...' );
  324.    Readln;
  325.    LoadFile( obj );        { Load objects from disk }
  326.    DoGraphics( obj )       { Display objects }
  327. END.
  328.